Sub ReProjectLayer (pLayer)
      'Get the new projection from the user
      Dim strPRJFile
      strPRJFile = CommonDialog.ShowOpen("prj", "Projection files|*.prj", "Select new projection")
      If IsEmpty(strPRJFile) Then
            Exit Sub
      End If
      'Create a CoordSys object with the selected PRJ file
      Dim pCS
      Set pCS = Application.CreateAppObject("CoordSys")
      pCS.Import(strPRJFile)
      'Get pLayer's RecordSet and Fields objects
      Dim pRS, pFields
      Set pRS = pLayer.Records
      Set pFields = pRS.Fields
      
      'Create a new shapefile to store the projected layer
      'Use pLayer's schema in the new shapefile
      Dim pNewRS, pCurrField, strNewSHPFileName
      strNewSHPFileName = Application.System.Properties("PersonalFolder") & "\" & pLayer.Name & "_prj.shp"
      Set pNewRS = Application.CreateAppObject("RecordSet")
      pNewRS.Create strNewSHPFileName, pFields.ShapeType, pCS
      For Each pCurrField In pFields
            pNewRS.Fields.Append pCurrField.Name, pCurrField.Type, pCurrField.DefinedSize, pCurrField.NumericScale
      Next
      
      'Iterate through all records in pLayer's recordset
      pRS.MoveFirst
      While Not pRS.EOF
            'Ignore records flagged for deletion
            If Not pRS.IsDeleted Then
                  'Write the current record's bookmark to the status bar
                  Application.StatusBar.Text = "#" & CStr(pRS.Bookmark)
                  'Add a new record to the new shapefile containing the current record's shape
                  'The shape's coordinates will automatically be reprojected to the projection of the new shapefile
                  pNewRS.AddNew pRS.Fields.Shape
                  'copy over all the attribute values to the new record of the new shapefile
                  For Each pCurrField In pFields
                        pNewRS.Fields(pCurrField.Name).Value = pCurrField.Value
                  Next
                  'Update the new record of the new shapefile to save the changes
                  pNewRS.Update
            End If
            pRS.MoveNext
      Wend
      'Clean up
      Set pCS = Nothing
      Set pRS = Nothing
      Set pFields = Nothing
      Set pNewRS = Nothing
      Set pCurrField = Nothing
      
      'Let the user know the process is complete
      MsgBox "Reprojection Complete.", vbInformation, "Reproject Tool"
End Sub